home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / modboot.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  15KB  |  546 lines
  1. /* ******************************************************************** */
  2. /*  modboot.c        Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  Wild thing II                                                       */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: modboot.c,v 1.13 1992/06/09 14:04:24 pab Exp $
  9.  *
  10.  * $Log: modboot.c,v $
  11.  * Revision 1.13  1992/06/09  14:04:24  pab
  12.  * fixed includes
  13.  *
  14.  * Revision 1.12  1992/05/26  11:28:03  pab
  15.  * map option added
  16.  *
  17.  * Revision 1.11  1992/04/27  21:57:29  pab
  18.  * correctied some casts
  19.  *
  20.  * Revision 1.10  1992/04/26  21:02:52  pab
  21.  * Added support for static_vectors, plus call to
  22.  * add_boot_module
  23.  * (Stardent bug gone now !)
  24.  *
  25.  * Revision 1.9  1992/03/13  18:12:02  pab
  26.  * sysV fix: move value vectors into shared space
  27.  * so GC can get to them.
  28.  *
  29.  * Revision 1.8  1992/01/29  13:42:45  pab
  30.  * binding fixes
  31.  *
  32.  * Revision 1.7  1992/01/09  22:28:55  pab
  33.  * Fixed for low tag ints
  34.  *
  35.  * Revision 1.6  1992/01/07  22:15:44  pab
  36.  * ncc compatable, plus backtrace
  37.  *
  38.  * Revision 1.5  1992/01/07  17:12:29  pab
  39.  * Added a cast. No sign of the stardent bug
  40.  *
  41.  * Revision 1.4  1992/01/05  22:48:09  pab
  42.  * Minor bug fixes, plus BSD version
  43.  *
  44.  * Revision 1.3  1991/12/22  15:14:19  pab
  45.  * Xmas revision
  46.  *
  47.  * Revision 1.2  1991/09/11  12:07:25  pab
  48.  * 11/9/91 First Alpha release of modified system
  49.  *
  50.  * Revision 1.1  1991/08/12  16:49:47  pab
  51.  * Initial revision
  52.  *
  53.  * Revision 1.4  1991/06/04  17:17:21  kjp
  54.  * No acceptable change.
  55.  *
  56.  * Revision 1.3  1991/02/13  18:23:36  kjp
  57.  * Pass.
  58.  *
  59.  */
  60.  
  61. #include <stdio.h>
  62. #include <string.h>
  63. #include <ctype.h>
  64.  
  65. #include "funcalls.h"
  66. #include "defs.h"
  67. #include "structs.h"
  68. #include "global.h"
  69.  
  70. #include "allocate.h"
  71. #include "symboot.h"
  72.  
  73. #include "ngenerics.h"
  74. #include "modules.h"
  75.  
  76. #include "table.h"
  77. #include "error.h"
  78.  
  79. #include "modboot.h"
  80. #include "bvf.h"
  81.  
  82. /* Current module information */
  83.  
  84. MODULE*  current_open_module; /* The thing itself */
  85. static int      entries;     /* No of entries it claims to have */
  86. static int      entry_count; /* The no of entries thus far */
  87.  
  88. /* Are we generating .i files... */
  89.  
  90. extern int command_line_interface_flag;
  91. #define CREATE_INTERFACE (command_line_interface_flag)
  92.  
  93. /* Interface generators... */
  94.  
  95. static FILE *i_file;
  96.  
  97. static void open_module_interface(char *name)
  98. {
  99.   char i_name[500];
  100.  
  101.   sprintf(i_name,"%s%s",MODULE_PATH,"../KerInterfaces/");
  102.  
  103.   strcat(i_name,name);
  104.   strcat(i_name,".i");
  105.  
  106.   i_file = fopen(i_name,"w");
  107.  
  108.   fprintf(i_file,"((dependencies)\n (exported-ids ");
  109.   fflush(i_file);
  110.   printf("Open %s - ",name); fflush(stdout);
  111. }
  112.  
  113. static void update_interface(char *name,int index,int argtype)
  114. {
  115.   fprintf(i_file,"\n   ((name . |%s|) (address %s . %d) (class . function) (argtype . %d))",
  116.       name,stringof(current_open_module->name->SYMBOL.pname),index,argtype);
  117.   fflush(i_file);
  118. }
  119.  
  120. static void close_module_interface()
  121. {
  122.   printf("closing - "); fflush(stdout);
  123.   fprintf(i_file,"))\n");
  124.   fflush(i_file);
  125.   fclose(i_file);
  126.   printf("closed\n"); fflush(stdout);
  127. }
  128.  
  129. void open_module(LispObject *stacktop, MODULE* mod,LispObject *vals,char* name,int ents)
  130. {
  131.   LispObject Fn_make_module(LispObject *);
  132.  
  133.   LispObject sym_name,lisp_ents;
  134.   if (current_open_module != NULL) {
  135.     fprintf(stderr,"\nINITERROR: tried to open '%s' while in '%s'\n",
  136.                name,current_open_module->name);
  137.     system_lisp_exit(1);
  138.   }
  139.  
  140.   sym_name = get_symbol(stacktop,name);
  141.   lisp_ents = allocate_integer(stacktop,ents);
  142.  
  143.   mod=(MODULE *)EUCALL_2(Fn_make_module,sym_name,lisp_ents);
  144.   /* Set up the fresh module */
  145.   
  146.   /* Set up tracking info */
  147.  
  148.   current_open_module = mod;
  149.   entries = ents;
  150.   entry_count = 0;
  151.   
  152.   /* Interface... */
  153.  
  154.   if (CREATE_INTERFACE) open_module_interface(name);
  155. }
  156.  
  157. LispObject make_module_function(LispObject *stacktop,char* lispname,
  158.                 LispObject (*fun)(LispObject*),int argcode)
  159. {
  160.   LispObject lfunc;
  161.   LispObject symbol,number;
  162.  
  163.   if (entry_count == entries) {
  164.     fprintf(stderr,
  165.         "\nINITERROR: more module functions that declared in '%s'\n",
  166.         stringof(current_open_module->name->SYMBOL.pname));
  167.     exit(1);
  168.   }
  169.  
  170.   symbol = get_symbol(stacktop,lispname); /* May or may not allocate anew */
  171.   STACK_TMP(symbol);
  172.  
  173.   vref((current_open_module->values),entry_count) = 
  174.     allocate_module_function(stacktop,(LispObject)current_open_module,
  175.                  symbol,fun,argcode);
  176.   number=allocate_integer(stacktop,entry_count);
  177.   UNSTACK_TMP(symbol);
  178.   /* GC Safe */
  179.  
  180.   ADD_BINDING(current_open_module,symbol,number,nil);
  181.  
  182.   current_open_module->exported_names = 
  183.     EUCALL_2(Fn_cons,symbol,current_open_module->exported_names);
  184.  
  185.   if (CREATE_INTERFACE) update_interface(lispname,entry_count,argcode);
  186.   ++entry_count;
  187.  
  188.   return(vref(current_open_module->values,entry_count-1));
  189. }
  190.  
  191. LispObject make_unexported_module_function(LispObject *stacktop,char* lispname,
  192.                        LispObject (*fun)(),int argcode)
  193. {
  194.   LispObject lfunc;
  195.   LispObject symbol,number;
  196.  
  197.   if (entry_count == entries) {
  198.     fprintf(stderr,
  199.         "\nINITERROR: more module functions that declared in '%s'\n",
  200.         stringof(current_open_module->name->SYMBOL.pname));
  201.     exit(1);
  202.   }
  203.  
  204.   symbol = get_symbol(stacktop,lispname); /* May or may not allocate anew */
  205.  
  206.   STACK_TMP(symbol);
  207.   vref((current_open_module->values),entry_count) = 
  208.     allocate_module_function(stacktop,(LispObject)current_open_module,
  209.                  symbol,fun,argcode);
  210.   number=allocate_integer(stacktop,entry_count);
  211.   UNSTACK_TMP(symbol);
  212.  
  213.   ADD_BINDING(current_open_module,symbol,number,nil);
  214.  
  215.  
  216.   /* Symbols can't be GC'd and modules are safe anyway!! */
  217.  
  218.   ++entry_count;
  219.  
  220. /*  fprintf(stderr,"%d OK\n",entry_count); fflush(stderr); */
  221.  
  222.   return(vref((current_open_module->values),entry_count-1));
  223. }
  224.  
  225. LispObject make_module_macro(LispObject *stacktop,char *name,LispObject (*func)(),int args)
  226. {
  227.   LispObject ret;
  228.  
  229.   ret = make_module_function(stacktop,name,func,args);
  230.   lval_typeof(ret) = TYPE_C_MACRO;
  231.  
  232.   return(ret);
  233. }
  234.  
  235. void close_module()
  236. {
  237.   if (current_open_module == NULL) {
  238.     fprintf(stderr,"\nINITERROR: tried to close NULL module\n");
  239.     exit(1);
  240.   }
  241.  
  242.   if (entries != entry_count) {
  243.     fprintf(stderr,
  244.         "\nINITERROR: tried to close '%s' with %d entries, %d needed\n",
  245.         stringof(current_open_module->name->SYMBOL.pname),entry_count,entries);
  246.     exit(1);
  247.   }
  248.  
  249. #ifdef BCI
  250.   add_boot_module((LispObject)current_open_module);
  251. #endif
  252.  
  253.   current_open_module = NULL;
  254.   if (CREATE_INTERFACE) close_module_interface();
  255. }
  256.  
  257.  
  258. LispObject make_unexported_module_special(LispObject *stacktop,char* lispname,LispObject (*fun)())
  259. {
  260.   LispObject number;
  261.   LispObject symbol;
  262.  
  263.   if (entry_count == entries) {
  264.     fprintf(stderr,
  265.         "\nINITERROR: more module functions that declared in '%s'\n",
  266.         stringof(current_open_module->name->SYMBOL.pname));
  267.     exit(1);
  268.   }
  269.  
  270.   symbol = get_symbol(stacktop,lispname); /* May or may not allocate anew */
  271.  
  272.   STACK_TMP(symbol);
  273.   vref((current_open_module->values),entry_count) = allocate_special(stacktop,symbol,fun);
  274.   number=allocate_integer(stacktop,entry_count);
  275.   UNSTACK_TMP(symbol);
  276.   
  277.   ADD_BINDING(current_open_module,symbol,number,nil);
  278.  
  279.   /* Symbols can't be GC'd and modules are safe anyway!! */
  280.  
  281.   ++entry_count;
  282.  
  283.   return(vref((current_open_module->values),entry_count-1));
  284. }
  285.  
  286. LispObject make_module_entry(LispObject *stacktop,char *name,LispObject value)
  287. {
  288.   LispObject symbol,number;
  289.  
  290.   if (entry_count == entries) {
  291.     fprintf(stderr,
  292.         "\nINITERROR: more module entries that declared in '%s'\n",
  293.         stringof(current_open_module->name->SYMBOL.pname));
  294.     exit(1);
  295.   }
  296.   vref((current_open_module->values),entry_count) = value; 
  297.  
  298.   STACK_TMP(value);
  299.   symbol = get_symbol(stacktop,name); /* May or may not allocate anew */
  300.   STACK_TMP(symbol);
  301.   number = allocate_integer(stacktop,entry_count);
  302.   UNSTACK_TMP(symbol); STACK_TMP(symbol);
  303.  
  304.   ADD_BINDING(current_open_module,symbol,number,nil);
  305.  
  306.   
  307.   UNSTACK_TMP(symbol);
  308.  
  309.   number =
  310.     EUCALL_2(Fn_cons,symbol,current_open_module->exported_names);
  311.   current_open_module->exported_names = number;
  312.  
  313.   if (CREATE_INTERFACE) update_interface(name,entry_count,-1);
  314.   ++entry_count;
  315.  
  316.   UNSTACK_TMP(value);
  317.   return(value);
  318. }
  319.  
  320.  
  321. LispObject make_module_entry_using_symbol(LispObject *stacktop,
  322.                       LispObject symbol,LispObject value)
  323. {
  324.   LispObject number;
  325.   if (entry_count == entries) {
  326.     fprintf(stderr,
  327.         "\nINITERROR: more module entries that declared in '%s'\n",
  328.         stringof(current_open_module->name->SYMBOL.pname));
  329.     exit(1);
  330.   }
  331.   
  332.  
  333.   vref((current_open_module->values),entry_count) = value; 
  334.  
  335.   STACK_TMP(value); STACK_TMP(symbol);
  336.   number = allocate_integer(stacktop,entry_count);
  337.   ADD_BINDING(current_open_module,symbol,number,nil);
  338.  
  339.   UNSTACK_TMP(symbol); STACK_TMP(symbol);
  340.   current_open_module->exported_names = 
  341.     EUCALL_2(Fn_cons,symbol,current_open_module->exported_names);
  342.   UNSTACK_TMP(symbol);
  343.  
  344.   if (CREATE_INTERFACE) update_interface(stringof(symbol->SYMBOL.pname),entry_count,-1);
  345.   ++entry_count;
  346.   UNSTACK_TMP(value);
  347.   return(value);
  348. }
  349.  
  350. LispObject make_module_special(LispObject *stacktop,
  351.                    char* lispname,LispObject (*fun)())
  352. {
  353.   LispObject lfunc;
  354.   LispObject symbol,number;
  355.  
  356.   if (entry_count == entries) {
  357.     fprintf(stderr,
  358.         "\nINITERROR: more module functions that declared in '%s'\n",
  359.         stringof(current_open_module->name->SYMBOL.pname));
  360.     exit(1);
  361.   }
  362.  
  363.   symbol = get_symbol(stacktop,lispname); /* May or may not allocate anew */
  364.   STACK_TMP(symbol);
  365.   vref((current_open_module->values),entry_count) = 
  366.     (LispObject) allocate_special(stacktop,symbol,fun);
  367.   number = allocate_integer(stacktop,entry_count);
  368.   UNSTACK_TMP(symbol);
  369.   STACK_TMP(symbol);
  370.  
  371.   UNSTACK_TMP(symbol);
  372.   /* Symbols can't be GC'd and modules are safe anyway!! */
  373.   ADD_BINDING(current_open_module,symbol,number,nil);
  374.  
  375.   current_open_module->exported_names = 
  376.     EUCALL_2(Fn_cons,symbol,current_open_module->exported_names);
  377.  
  378.   ++entry_count;
  379.  
  380.   return(vref((current_open_module->values),entry_count-1));
  381. }
  382.  
  383. LispObject make_module_generic(LispObject *stackbase,char *name,int code)
  384. {
  385.   LispObject sym,number,tmp;
  386.   LispObject *stacktop=stackbase+1,*gf=stackbase;
  387.   if (entry_count == entries) {
  388.     fprintf(stderr,
  389.         "\nINITERROR: more module functions that declared in '%s'\n",
  390.         stringof(current_open_module->name->SYMBOL.pname));
  391.     exit(1);
  392.   }
  393.  
  394.   *gf=nil;
  395.   vref(current_open_module->values,entry_count) =
  396.     allocate_instance(stacktop,Generic);
  397.  
  398.   *gf=vref(current_open_module->values,entry_count);
  399.   generic_home(*gf) = (LispObject)current_open_module;
  400.   lval_typeof(*gf)=TYPE_GENERIC;
  401.  
  402.   sym = get_symbol(stacktop,name);
  403.   STACK_TMP(sym);
  404.   tmp = allocate_integer(stacktop,code);
  405.   generic_argtype(*gf)=tmp;
  406.   number=allocate_integer(stacktop,entry_count);
  407.   UNSTACK_TMP(sym);
  408.  
  409.   STACK_TMP(number); STACK_TMP(sym);
  410.   generic_name(*gf) = sym;
  411.  
  412.   generic_discriminator(*gf) = nil;
  413.   generic_slow_method_cache(*gf) = nil;
  414.   generic_fast_method_cache(*gf) = nil;
  415.   generic_method_table(*gf) = nil;
  416.   
  417.   generic_method_class(*gf) = Method;
  418.   
  419.   UNSTACK_TMP(sym); UNSTACK_TMP(number);
  420.   STACK_TMP(sym);
  421.  
  422.   ADD_BINDING(current_open_module,sym,number,nil);
  423.   UNSTACK_TMP(sym);
  424.   /* Symbols can't be GC'd and modules are safe anyway!! */
  425.  
  426.   current_open_module->exported_names = 
  427.     EUCALL_2(Fn_cons,sym,current_open_module->exported_names);
  428.  
  429.   if (CREATE_INTERFACE) update_interface(name,entry_count,code);
  430.   ++entry_count;
  431.  
  432.   return(*gf);
  433. }
  434.  
  435. LispObject make_wrapped_module_generic(LispObject *stacktop,char *name,int code,
  436.                        LispObject (*fun)())
  437. {
  438.   LispObject number;
  439.   LispObject sym,gf,tmp;
  440.   LispObject *stackbase=stacktop;
  441.  
  442.   ARG_0(stackbase) = nil; /*gf*/
  443.   ARG_1(stackbase)=nil; /* number*/
  444.   ARG_2(stackbase)=nil; /*sym*/
  445.  
  446.   stacktop+=3;
  447.   if (entry_count == entries) {
  448.     fprintf(stderr,
  449.         "\nINITERROR: more module functions that declared in '%s'\n",
  450.         stringof(current_open_module->name->SYMBOL.pname));
  451.     exit(1);
  452.   }
  453.  
  454.   sym = get_symbol(stacktop,name);
  455.   ARG_2(stackbase)=sym;
  456.   ARG_0(stackbase) = vref(current_open_module->values,entry_count) =
  457.     allocate_instance(stacktop,Generic);
  458.  
  459.   
  460.   lval_typeof(ARG_0(stackbase))=TYPE_GENERIC;
  461.   generic_home(ARG_0(stackbase)) = (LispObject)current_open_module;
  462.   tmp = allocate_integer(stacktop,code);
  463.   generic_argtype(ARG_0(stackbase)) =tmp;
  464.   generic_name(ARG_0(stackbase)) = ARG_2(stackbase);
  465.   
  466.   generic_fast_method_cache(ARG_0(stackbase)) = nil;
  467.   generic_slow_method_cache(ARG_0(stackbase)) = nil;
  468.   ARG_1(stackbase)=allocate_integer(stacktop,entry_count);
  469.  
  470.   generic_method_table(ARG_0(stackbase)) = nil;
  471.   generic_method_class(ARG_0(stackbase)) = Method;
  472.  
  473.   generic_discriminator(ARG_0(stackbase)) = nil;
  474.  
  475.   ADD_BINDING(current_open_module,ARG_2(stackbase),ARG_1(stackbase),nil);
  476.  
  477.   /* Symbols can't be GC'd and modules are safe anyway!! */
  478.  
  479.   tmp =
  480.     EUCALL_2(Fn_cons,ARG_2(stackbase),current_open_module->exported_names);
  481.   current_open_module->exported_names = tmp;
  482.  
  483.   if (CREATE_INTERFACE) update_interface(name,entry_count,code);
  484.   ++entry_count;
  485.  
  486.   return(ARG_0(stackbase));
  487. }
  488.  
  489.  
  490. /*
  491.  
  492.  * Environment functions...
  493.  
  494.  */
  495.  
  496. LispObject make_anonymous_module_env_function_1(LispObject *stacktop,
  497.                         LispObject mod,
  498.                         LispObject (*fun)(LispObject*),
  499.                         int argtype,
  500.                         LispObject sym,
  501.                         LispObject val)
  502. {
  503.   LispObject lfunc;
  504.   LispObject env;
  505.  
  506.   STACK_TMP(sym); STACK_TMP(val);
  507.   lfunc = allocate_module_function(stacktop,mod,nil,fun,argtype); /* GC Safe */
  508.   UNSTACK_TMP(val); UNSTACK_TMP(sym);
  509.   STACK_TMP(lfunc);
  510.   /* Rig the environment... */
  511.  
  512.   env = allocate_env(stacktop,sym,val,NULL);
  513.   UNSTACK_TMP(lfunc);
  514.   lfunc->C_FUNCTION.env = &env->ENV;
  515.  
  516.   return(lfunc);
  517. }
  518.  
  519. LispObject make_anonymous_module_env_function_2(LispObject *stacktop,
  520.                         LispObject mod,
  521.                         LispObject (*fun)(LispObject*),
  522.                         int argtype,
  523.                         LispObject sym1,
  524.                         LispObject val1,
  525.                         LispObject sym2,
  526.                         LispObject val2)
  527. {
  528.   LispObject lfunc;
  529.   LispObject env;
  530.   STACK_TMP(sym2); STACK_TMP(val2);
  531.   STACK_TMP(sym1); STACK_TMP(val1);
  532.   lfunc = allocate_module_function(stacktop,mod,nil,fun,argtype); /* GC Safe */
  533.   
  534.   /* Rig the environment... */
  535.   UNSTACK_TMP(val1); UNSTACK_TMP(sym1); STACK_TMP(lfunc);
  536.   env = allocate_env(stacktop,sym1,val1,NULL);
  537.   UNSTACK_TMP(lfunc);
  538.   UNSTACK_TMP(val2); UNSTACK_TMP(sym2); STACK_TMP(lfunc);
  539.   env = allocate_env(stacktop,sym2,val2,env);
  540.   UNSTACK_TMP(lfunc);
  541.   lfunc->C_FUNCTION.env = (Env)env;
  542.  
  543.   return(lfunc);
  544. }
  545.  
  546.